home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-03 / qbasicpg.zip / DATABASE.BAS < prev    next >
BASIC Source File  |  1982-04-14  |  8KB  |  158 lines
  1. 5 CLEAR 10000:DIM L(30),Q$(30):REM Length - Question & Data
  2. 7 C$="...............................: "
  3. 8  B$="    "
  4. 10 REM  ----- Ageneral data base program for the micropolis users group ---
  5. 11 REM --- written by ELWOOD Clarke for all to use - uncopyrightable---
  6. 12 REM   SET UP THE SIZE OF THE VARIABLE MATRIX
  7. 15 CLS
  8. 20 INPUT "The file name of the stored data ";F$
  9. 100 REM --- This is the menu section from line 100 - 199
  10. 105 CLS:REM  Clear the screen
  11. 110 PRINT "Init......Initalizes this file"
  12. 120 PRINT "Entr......Enters data"
  13. 130 PRINT "Look......Looks at data"
  14. 140 PRINT "Chng......Changes data"
  15. 150 PRINT "Srch......Searches for data"
  16. 160 PRINT "Del.......Deletes record"
  17. 165 PRINT "Quit......Leaves the program"
  18. 170 INPUT "Which function would you like ";O$
  19. 180 O$=LEFT$(O$,1):REM Take the first character of the answer
  20. 190 A=(O$="I")+(O$="E")*2+(O$="L")*3+(O$="C")*4+(O$="S")*5+(O$="D")*6+(O$="Q")*7:REM   Depending on 1 through 6
  21. 192 A=A+(O$="i")+(O$="e")*2+(O$="l")*3+(O$="c")*4+(O$="s")*5+(O$="d")*6+(O$="q")*7:REM  accept also lower case letters
  22. 193 A=ABS(A):A=A+1
  23. 195 ON A GOTO 100,200,300,400,500,600,700,800
  24. 200 REM ---- This is the file initialization program ---
  25. 205 GOSUB 1000: REM  REM   Open the file used for data storage
  26. 210 INPUT  " How many input questions are there?";L(0)
  27. 215 FOR X=1 TO L(O):REM   This loop lets one enter the questions
  28. 220    PRINT  "Enter the desired question for ";X;:INPUT  " ";Q$(X)
  29. 225 NEXT X
  30. 230 FOR X=1 TO L(0):REM Print out question list for error checking
  31. 235    PRINT X;"   ";Q$(X)
  32. 240 NEXT X
  33. 245 INPUT "The desired item to be corrected & `0' if none";X
  34. 250 IF X=0 THEN 280:REM   If all are correct save them
  35. 255 IF (X<1) OR (X>L(0)) THEN 245:REM  Out of range quewtions
  36. 260 INPUT "What should the new item be ";Q$(X)
  37. 265 GOTO 230: REM   End the edit of the questions
  38. 280 N=0:GOSUB 2000: REM   Pack the data and then return
  39. 285 Q1=1:GOSUB 1200:REM   Save record 1 which contains questions
  40. 290 GOSUB 1100: REM    Close the file
  41. 299 GOTO 100: REM    Return to the menu
  42. 300 REM    This is the data entry program----
  43. 305 GOSUB 1000: REM    Open the file used for data storage
  44. 310 Q1=1:GOSUB 1230:GOSUB 2100: REM----Get the file information and unpack it
  45. 315 FOR X=1 TO L(0): REM ---Input data loop
  46. 320   PRINT Q$(X);RIGHT$(C$,25-LEN(Q$(X)));:INPUT D$(X)
  47. 325 NEXT X
  48. 330 FOR X=1 TO L(0):PRINT X;"  ";Q$(X);RIGHT$(C$,25-LEN(Q$(X)));D$(X):NEXT X
  49. 335 INPUT  "Item number to be changed `0' if none ";X
  50. 340 IF X=0 THEN 370: REM ---If none then save the results
  51. 345 IF (X<1) OR (X>L(0)) THEN 335: REM---Out of range data value
  52. 350 PRINT Q$(X);"Should be ";:INPUT  D$(X): REM ---Correct it
  53. 355 GOTO 330: REM ---End of correct loop
  54. 370 N=N+1:GOSUB 2001:GOSUB 1200: REM ---Resave file header
  55. 375 GOSUB 2200:Q1=2*N+1:GOSUB 1200:REM ---Pack and save data on file in record n+1
  56. 380 GOSUB 1100: REM ---Close the file
  57. 399 GOTO 100: REM ---Return to the menu
  58. 400 REM ---This is the data inspection program---
  59. 401 GOSUB 1000: REM ---Open the file used for data storage---
  60. 405 Q1=1:GOSUB 1230:GOSUB 2100: REM ---Get file information and unpack it---
  61. 410 PRINT  "Which record would you like to see?"
  62. 411 PRINT "0=none, 1=min, ";N;"=max ";:INPUT X
  63. 415 IF (X=0) THEN GOTO 495
  64. 420 IF (X>N) THEN PRINT "Invalid Record Number": GOTO 410
  65. 430 Q1= 2*X+1:GOSUB 1230: REM ---Get the desired record to look at
  66. 440 GOSUB 2300: REM ---Unpack the record---
  67. 450 FOR X=1 TO L(0):PRINT X;"  ";Q$(X);RIGHT$(C$,25-LEN(Q$(X)));D$(X):NEXT X
  68. 460 INPUT "Another Record (Y or N)";W$
  69. 470 IF (W$="Y") OR (W$="y") THEN CLS: GOTO 405
  70. 495 GOSUB 1100: REM ---Close the file---
  71. 499 GOTO 100:REM ---Return to the menu---
  72. 500 REM ---This is the data change program---
  73. 505 GOSUB 1000: REM ---Open the file used for data storage---
  74. 510 Q1=1:GOSUB 1230:GOSUB 2100: REM ---Get file information and unpack it---
  75. 515 INPUT  "Which record would you like to change ";Z
  76. 520 IF (Z<1) OR (Z>N) THEN 515: REM ---Not a legal record goto 515
  77. 525 Q1=2*Z+1:GOSUB 1230:GOSUB 2300: REM ---Get and unpack desired record---
  78. 530 FOR X=1 TO L(0):PRINT X;"  ";Q$(X);RIGHT$(C$,25-LEN(Q$(X)));D$(X):NEXT X
  79. 535 INPUT "The number of the item to be changed & `0' if none ";I
  80. 540 IF I=0 THEN 580: REM ---Go store result---
  81. 545 IF (I<1) OR (I>L(0)) THEN 535: REM ---Illegal item number---
  82. 550 PRINT Q$(I);" Should be ";:INPUT D$(I): REM ---Input correct answer---
  83. 555 GOTO 530: REM ---Print out correct data and ask for more corrections---
  84. 580 GOSUB 2200:Q1=2*Z+1:GOSUB 1200:REM ---Pack and save data back onto disk---
  85. 590 GOSUB 1100:REM ---Close the file---
  86. 599 GOTO 100:REM --- Return to the menu---
  87. 600 REM ---This is the data search program---
  88. 601 GOSUB 1000:REM ---Open the file used for data storage---
  89. 605 Q1=1:GOSUB 1230:GOSUB 2100:REM ---Pack and save data back onto disk
  90. 610 FOR X=1 TO L(0):PRINT X;"  ";Q$(X):NEXT X:REM ---List the fields---
  91. 620 INPUT "Which item would you like to search ";I
  92. 625 IF (I<1) OR (I>L(0)) THEN PRINT "Not a Valid Item": GOTO 620
  93. 627 INPUT "What should that item be ";E$
  94. 630 FOR Y=0 TO N:Q1=2*Y+1:GOSUB 1230:GOSUB 2300:REM ---Get and unpack each record---
  95. 640 IF E$=LEFT$(D$(I),LEN(E$)) THEN PRINT  Y;LEFT$(B$,4-LEN(STR$(Y)));:FOR Z=1 TO L(0):PRINT D$(Z);"  ";:NEXT Z:PRINT :REM ---If item found print record---
  96. 645 NEXT Y
  97. 660 INPUT "Another Search (Y or N)";E$
  98. 670 IF (E$="Y") OR (E$="y") THEN CLS: GOTO 610
  99. 690 GOSUB 1100: REM ---Close file---
  100. 699 GOTO 100:REM ---Return to the menu---
  101. 700 REM ---This is the data delete program---
  102. 705 GOSUB 1000: REM ---Open the file used for data storage---
  103. 710 Q1=1:GOSUB 1230:GOSUB 2100:REM ---Get file information and unpack it---
  104. 715 INPUT "Which record would you like to delete? `0'if none";I
  105. 720 IF (I=0) THEN 790: REM ---Don't delete any
  106. 725 IF (I>N) OR (I<0) THEN 715: REM ---Not a legal record---
  107. 730 IF (I=N) THEN 780: REM ---Delete last record---
  108. 735 FOR X=I TO N-1:Q1=2*X+3:GOSUB 1230:Q1=2*X+1:GOSUB 1200:NEXT X:REM ---Shift all following records---
  109. 780 N=N-1:GOSUB 2000:Q1=1:GOSUB 1200: REM --Reset the header back one pointer--
  110. 790 GOSUB 1100: REM --close the file ---
  111. 799 GOTO 100: REM ---Return to the menu---
  112. 800 END
  113. 1000 OPEN "R",1,F$:FIELD 1,127 AS B$:RETURN: REM ---Open file-all results=B$---
  114. 1100 CLOSE 1:RETURN:REM ---Close that file---
  115. 1199 REM ---PUT SUBROUTINE---
  116. 1200 IF LEN(A$)>127 THEN LSET B$=LEFT$(A$,127):PUT 1,Q1:LSET B$=RIGHT$(A$,(LEN(A$)-127)):PUT 1,Q1+1:RETURN
  117. 1210 LSET B$=A$:PUT 1,Q1:LSET B$="  ":PUT 1,Q1+1:RETURN
  118. 1220 REM ---GET SUBROUTINE---
  119. 1230 GET 1,Q1:M$=B$:GET 1,Q1+1:N$=B$:A$=M$+N$:RETURN
  120. 2000 REM ---PACKING AND UNPACKING SUBROUTINES---
  121. 2001 REM Pack 0 a$ is N,L(0),L(1),...L(N),Q$(1),...Q$(X)
  122. 2002 A$=MKI$(N)+MKI$(L(0)):REM ---First enter the number of records---
  123. 2003 FOR X=1 TO L(0):REM Then the number of fields and lengths of fields
  124. 2004 L(X)=LEN(Q$(X)):A$=A$+MKI$(L(X))
  125. 2005 NEXT X
  126. 2006 FOR X=1 TO L(0):REM  Then store the question in record 0
  127. 2007 A$=A$+Q$(X)
  128. 2008 NEXT X
  129. 2009 RETURN
  130. 2100 REM Unpack record 0
  131. 2101 L(0)=CVI(MID$(A$,3,2)):N=CVI(MID$(A$,1,2)):REM number of fields and records
  132. 2102 LT=5+2*L(0):REM Starting byte position
  133. 2103 FOR X=1 TO L(0):REM Unpacking strings
  134. 2104 L(X)=CVI(MID$(A$,2*X+3,2))
  135. 2105 Q$(X)=MID$(A$,LT,L(X))
  136. 2106 LT=LT+L(X):REM Pointer for the next string
  137. 2107 NEXT X
  138. 2108 RETURN
  139. 2200 REM Pack n - packs records for record n
  140. 2201 A$=""
  141. 2202 FOR X=1 TO L(0):REM pack record n
  142. 2203 L(X)=LEN(D$(X)):A$=A$+MKI$(L(X))
  143. 2204 NEXT X
  144. 2205 FOR X=1 TO L(0)
  145. 2206 A$=A$+D$(X)
  146. 2207 NEXT X
  147. 2208 RETURN
  148. 2300 REM Unpack n - unpacks record n
  149. 2301 LT=2*L(0)+1
  150. 2302 FOR X=1 TO L(0)
  151. 2303 L(X)=CVI(MID$(A$,2*X-1,2))
  152. 2304 D$(X)=MID$(A$,LT,L(X))
  153. 2305 LT=LT+L(X):NEXT X
  154. 2306 RETURN
  155. 0)+1
  156. 2302 FOR X=1 TO L(0)
  157. 2303 L(X)=CVI(MID$(A$,2*X-1,2))
  158. 2304 D$(